home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / table.lisp < prev    next >
Text File  |  1991-07-15  |  63KB  |  1,639 lines
  1. ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21. (in-package "CLIO-OPEN")
  22.  
  23.  
  24. (export '(
  25.       table
  26.       make-table
  27.       table-column-alignment
  28.       table-column-width
  29.       table-columns
  30.       table-delete-policy
  31.       table-layout-size-policy
  32.       table-member
  33.       table-row-alignment
  34.       table-row-height
  35.       table-same-height-in-row
  36.       table-same-width-in-column
  37.       table-separator
  38.       table-row
  39.       table-column
  40.       )
  41.     'clio-open)
  42.  
  43. ;;;
  44. ;;;  Call-Tree...
  45. ;;;
  46.  
  47.  
  48. ;;;   Preferred-Size (Table)
  49. ;;;   .  check-for-existing-wis
  50. ;;;   .  place-children-physically
  51. ;;;   .  .  put-kids-into-maximum-unaligned-columns
  52. ;;;   .  .  .  find-first-parents-width 
  53. ;;;   .  .  .  assign-kids-to-rows-and-columns
  54. ;;;   .  .  .  preferred-size (child)
  55. ;;;   .  .  .  move (child)
  56. ;;;   .  .  .  resize (child)
  57. ;;;   .  .  put-kids-into-maximum-aligned-columns
  58. ;;;   .  .  .  assign-kids-to-rows-and-columns
  59. ;;;   .  .  .  .  assign-a-kid-to-a-row-and-column
  60. ;;;   .  .  .  .  build-sorted-list-of-children
  61. ;;;   .  .  .  get-maximum-possible-ncolumns
  62. ;;;   .  .  .  .  preferred-size (child)
  63. ;;;   .  .  .  preferred-size (child)
  64. ;;;   .  .  .  adjust-column-widths-so-child-fits
  65. ;;;   .  .  put-kids-into-specified-number-of-columns   
  66. ;;;   .  .  .  assign-kids-to-rows-and-columns
  67. ;;;   .  .  .  preferred-size (child)
  68. ;;;   .  .  scan-for-largest-children
  69. ;;;   .  .  .  preferred-size (child)
  70. ;;;   .  .  determine-a-rows-height
  71. ;;;   .  .  preferred-size (child)
  72. ;;;   .  .  move (child)
  73. ;;;   .  .  resize (child)
  74. ;;;   .  .  calculate-preferred-height
  75. ;;;   .  .  determine-a-rows-height
  76. ;;;   .  .  .  preferred-size (child)
  77. ;;;   .  .  calculate-preferred-width
  78. ;;;   .
  79. ;;;   Change-Layout(Table)
  80. ;;;   .  check-for-existing-wis
  81. ;;;   .  place-children-physically
  82. ;;;   .  change-geometry (Table)
  83. ;;;   .
  84. ;;;   Resize :after (Table)
  85. ;;;   .  change-layout (Table)
  86. ;;;   .
  87. ;;;   Manage-Geometry (Table)
  88. ;;;   .  Change-Geometry (Table)
  89.  
  90. ;;;  Basic Organization and Flow:
  91. ;;;    The Table contact lays out its children per the values of its policy resources and the
  92. ;;;    row/column constraints of its children, with the resource values always taking precedence
  93. ;;;    over the children's constraint values.  
  94. ;;;
  95. ;;;    The function place-children-physically does the real work of Table.  
  96. ;;;
  97. ;;;    The differences in Table's logical flow for the possible values for the :columns resource
  98. ;;;    are embodied primarily in the three routines
  99. ;;;
  100. ;;;        put-kids-into-maximum-unaligned-columns
  101. ;;;        put-kids-into-maximum-aligned-columns
  102. ;;;        put-kids-into-specified-number-of-columns
  103. ;;;
  104. ;;;    There are 5 ways into the Table contact's logic:
  105. ;;;
  106. ;;;        Preferred-Size (Table)
  107. ;;;        Change-Layout (Table)
  108. ;;;        Resize :after (Table)
  109. ;;;        Manage-Geometry (Table)
  110. ;;;        (SETF layout-policy-resource)
  111. ;;;
  112.  
  113.  
  114. ;;;  ===========================================================================
  115. ;;;        T h e   T A B L E   L a y o u t   C o n t a c t 
  116. ;;;  ===========================================================================
  117.  
  118. (DEFCONTACT table (gravity-mixin spacing-mixin core composite)
  119.   ((column-alignment    :type        (MEMBER :left :center :right)
  120.             :reader      table-column-alignment    ; SETF method defined below.
  121.             :initarg    :column-alignment
  122.             :initform    :left)
  123.    
  124.    (column-width    :type        (OR (MEMBER :maximum) cons (integer 1 *))
  125.             :reader      table-column-width    ; SETF method defined below.
  126.             :initarg    :column-width
  127.             :initform    :maximum)
  128.    
  129.    (columns        :type        (OR (integer 1 *) (MEMBER :maximum :none))
  130.             :reader      table-columns            ; SETF method defined below.
  131.             :initarg    :columns
  132.             :initform    :maximum)
  133.  
  134.    (delete-policy    :type          (MEMBER :shrink-list :shrink-column :shrink-none :shrink-row)
  135.             :reader      table-delete-policy    ; SETF method defined below.
  136.             :initarg    :delete-policy
  137.             :initform    :shrink-none)
  138.  
  139.    (layout-size-policy    :type        (MEMBER :maximum :minimum :none)
  140.             :reader      table-layout-size-policy ; SETF method defined below.
  141.             :initarg    layout-size-policy
  142.             :initform    :maximum)
  143.  
  144.    (row-height        :type        (OR (MEMBER :maximum) cons (integer 1 *))
  145.             :reader      table-row-height    ; SETF method defined below.
  146.             :initarg    :row-height
  147.             :initform    :maximum)
  148.  
  149.    (row-alignment    :type        (MEMBER :top :center :bottom)
  150.             :reader      table-row-alignment    ; SETF method defined below.
  151.             :initarg    :row-alignment
  152.             :initform    :bottom)
  153.  
  154.    (same-height-in-row
  155.                  :type        (MEMBER :on :off)
  156.             :reader      table-same-height-in-row ; SETF method defined below.
  157.             :initarg    :same-height-in-row
  158.             :initform       :off)
  159.  
  160.    (same-width-in-column
  161.                  :type        (MEMBER :on :off)
  162.             :reader      table-same-width-in-column ; SETF method defined below.
  163.             :initarg    :same-width-in-column
  164.             :initform    :off)
  165.  
  166.    (separators        :type        list
  167.             :initarg    :separators
  168.             :initform    nil))
  169.  
  170.   (:resources
  171.     (border-width :initform 0)
  172.     column-alignment
  173.     column-width
  174.     columns
  175.     delete-policy
  176.     layout-size-policy
  177.     row-alignment    
  178.     row-height
  179.     same-height-in-row
  180.     same-width-in-column
  181.     separators)
  182.  
  183.  
  184.   (:constraints
  185.     (row         :type         (integer 0 *))
  186.     (column         :type         (integer 0 *)))
  187.  
  188.  
  189.   (:documentation
  190.     "Arranges its children in an array of rows and columns."
  191.     ))
  192.  
  193.  
  194.  
  195. (DEFUN make-table (&rest initargs &key &allow-other-keys)
  196.   (APPLY #'make-contact 'table initargs))
  197.  
  198. ;;;  ===========================================================================  ;;; 
  199. ;;;          ORG-ENTRY: the entries on the what-if-organization list          ;;;
  200. ;;;  ===========================================================================  ;;;
  201.  
  202. (DEFSTRUCT (org-entry :named (:type vector) (:conc-name "ORG-ENTRY-"))
  203.   kid
  204.   row
  205.   column
  206.   width
  207.   height
  208.   border-width)
  209.  
  210. (DEFUN establish-org-entry (kid row column)
  211.   (MULTIPLE-VALUE-BIND (p-w p-h p-b-w)
  212.       (preferred-size kid)
  213.     (make-org-entry :kid kid :row row :column column
  214.             :width p-w :height p-h :border-width p-b-w)))
  215.  
  216.  
  217. ;;;  ===========================================================================  ;;; 
  218. ;;;               What-if Structures and Their management              ;;;
  219. ;;;  ===========================================================================  ;;;
  220.  
  221. ;;;
  222. ;;;   Structures of this kind are placed on the Table's plist under the :what-if-structures
  223. ;;;   property to record already-performed preferred-size calculations for the current set of
  224. ;;;   policy resource values but different widths/heights.  Any change to a policy resource
  225. ;;;   destroys this cache of what-if structures, as does a call to change-layout.
  226. ;;;
  227.  
  228. ;;;   Hmmmm...  We must keep the children's sizes here, have all the layout logic look here
  229. ;;;   rather than at the kids' preferred-size methods.  Where to keep this info?  In organization
  230. ;;;   (which is already a list of the kids) or in another list of kids, widths, heights, and
  231. ;;;   border-widths.  Or in an array...
  232.  
  233. (DEFSTRUCT (what-if-structure :named (:type vector) (:conc-name "WHAT-IF-"))
  234.   width
  235.   height
  236.   border-width
  237.   organization                    ; org-entrys for :mapped children only!
  238.   column-widths
  239.   nrows
  240.   ncolumns
  241.   (preferred-width 0)
  242.   (preferred-height 0)
  243.   in-use
  244.   )
  245.  
  246. (DEFUN check-for-existing-wis (table width height border-width &optional dont-create-p)
  247.   ;;  Returns the first (newest) wis found with width/height.
  248.   ;;  If no wis satisfying width/height exists, create a new one unless DONT-CREATE-P
  249.   ;;  is true, in which case return NIL.
  250.   (DECLARE (VALUES (OR what-if-structure NULL)))
  251.   (LET ((old-wis-list (GETF (window-plist table) :what-if-structures)) wis)
  252.     (SETF wis (FIND-IF #'(lambda (wis)
  253.                (AND (EQL (what-if-width wis) width)
  254.                 (EQL (what-if-height wis) height)
  255.                 (EQL (what-if-border-width wis) border-width)))
  256.                old-wis-list))
  257.     (UNLESS (OR wis dont-create-p)
  258.       (SETF (GETF (window-plist table) :what-if-structures)
  259.         (PUSH (SETF wis (make-what-if-structure :width width
  260.                             :height height
  261.                             :border-width border-width
  262.                             :preferred-width 0
  263.                             :preferred-height 0))
  264.           old-wis-list))
  265.       )
  266.     wis))
  267.  
  268.  
  269. ;;;  ===========================================================================  ;;; 
  270. ;;;                 A Table's Constraint's Accessors              ;;;
  271. ;;;  ===========================================================================  ;;;
  272.  
  273.  
  274. (defun table-row (member)
  275.   (declare (values (or null (integer 0 *))))
  276.   (contact-constraint member :row))
  277.  
  278. (defsetf table-row setf-table-row)
  279. (defun setf-table-row (member row)
  280.   (check-type row (or null (integer 0 *)))
  281.   (setf (contact-constraint member :row) row))
  282.  
  283. (defun table-column (member)
  284.   (declare (values (or null (integer 0 *))))
  285.   (contact-constraint member :column))
  286.  
  287. (defsetf table-column setf-table-column)
  288. (defun setf-table-column (member column)
  289.   (check-type column (or null (integer 0 *)))
  290.   (setf (contact-constraint member :column) column))
  291.  
  292.  
  293.  
  294.  
  295. ;;;  ===========================================================================  ;;; 
  296. ;;;               SETF functions for a Table's Resources              ;;;
  297. ;;;  ===========================================================================  ;;; 
  298.  
  299. (defmethod (setf display-left-margin) :after (new-value (table table))
  300.   (declare (ignore new-value))
  301.   (change-layout table))
  302.  
  303. (defmethod (setf display-right-margin) :after (new-value (table table))
  304.   (declare (ignore new-value))
  305.   (change-layout table))
  306.  
  307. (defmethod (setf display-top-margin) :after (new-value (table table))
  308.   (declare (ignore new-value))
  309.   (change-layout table))
  310.  
  311. (defmethod (setf display-bottom-margin) :after (new-value (table table))
  312.   (declare (ignore new-value))
  313.   (change-layout table))
  314.  
  315.  
  316.  
  317. (defun force-relayout (table)
  318.   (SETF (GETF (window-plist table) :what-if-structures) nil)
  319.   (change-layout table))
  320.  
  321. (DEFMETHOD (SETF display-horizontal-space) :after (new-value (table table))
  322.   (DECLARE (IGNORE new-value))
  323.   (force-relayout table))
  324.  
  325. (DEFMETHOD (SETF table-column-alignment) (new-value (table table))
  326.   (with-slots (column-alignment)
  327.     table
  328.     (SETF column-alignment new-value)
  329.     (force-relayout table)
  330.     new-value))
  331.   
  332. (DEFMETHOD (SETF table-column-width) (new-value (table table))
  333.   (with-slots (column-width)
  334.     table
  335.     (SETF column-width new-value)
  336.     (force-relayout table)
  337.     new-value))
  338.   
  339. (DEFMETHOD (SETF table-columns) (new-value (table table))
  340.   (with-slots (columns)
  341.     table
  342.     (SETF columns new-value)
  343.     (DOLIST (kid (composite-children table))
  344.       (SETF (table-column kid) nil
  345.         (table-row kid) nil))
  346.     (force-relayout table)
  347.     new-value))
  348.   
  349. (DEFMETHOD (SETF table-delete-policy) (new-value (table table))
  350.   (with-slots (delete-policy)
  351.     table
  352.     (SETF delete-policy new-value)
  353.     (force-relayout table)
  354.     new-value))
  355.   
  356. (DEFMETHOD (SETF table-layout-size-policy) (new-value (table table))
  357.   (with-slots (layout-size-policy)
  358.     table
  359.     (SETF layout-size-policy new-value)
  360.     (force-relayout table)
  361.     new-value))
  362.   
  363. (DEFMETHOD (SETF table-row-height) (new-value (table table))
  364.   (with-slots (row-height)
  365.     table
  366.     (SETF row-height new-value)
  367.     (force-relayout table)
  368.     new-value))
  369.   
  370. (DEFMETHOD (SETF table-row-alignment) (new-value (table table))
  371.   (with-slots (row-alignment)
  372.     table
  373.     (SETF row-alignment new-value)
  374.     (force-relayout table)
  375.     new-value))
  376.   
  377. (DEFMETHOD (SETF table-same-width-in-column) (new-value (table table))
  378.   (CHECK-TYPE new-value (MEMBER :on :off))
  379.   (with-slots (same-width-in-column)
  380.     table
  381.     (SETF same-width-in-column new-value)
  382.     (force-relayout table)
  383.     new-value))
  384.   
  385. (DEFMETHOD (SETF table-same-height-in-row) (new-value (table table))
  386.   (CHECK-TYPE new-value (MEMBER :on :off))
  387.   (with-slots (same-height-in-row)
  388.     table
  389.     (SETF same-height-in-row new-value)
  390.     (force-relayout table)
  391.     new-value))
  392.   
  393.   
  394. ;;;  ===========================================================================  ;;; 
  395. ;;;                 A Table's Separator Methods                     ;;;
  396. ;;;  ===========================================================================  ;;;
  397.   
  398. ;;;  Note: The physical size of an OL UI separator (white-space) will be defined 
  399. ;;;       to be half the height of the row it follows.
  400.   
  401. (DEFMETHOD table-separator ((table table) row-number)
  402.   (DECLARE (type integer row-number)
  403.        (VALUES (MEMBER :on :off)))
  404.   (check-type row-number (integer 0 *))
  405.   (with-slots (separators)
  406.     table
  407.     (IF (MEMBER row-number separators) :on :off)))
  408.   
  409.   
  410. (DEFMETHOD (SETF table-separator) (on-or-off (table table) row-number)
  411.   (DECLARE (type integer row-number)
  412.        (VALUES (MEMBER :on :off)))
  413.   (check-type row-number (integer 0 *))
  414.   (with-slots (separators)
  415.     table
  416.     (LET ((already-there-p (MEMBER row-number separators)))
  417.       (ECASE on-or-off
  418.     (:on (UNLESS already-there-p
  419.            (PUSH row-number separators)
  420.            (force-relayout table)))
  421.     (:off (WHEN already-there-p
  422.         (SETF separators (DELETE row-number separators))
  423.         (force-relayout table))))))    
  424.   on-or-off)
  425.   
  426.   
  427.   
  428.   
  429. ;;;  ===========================================================================  ;;; 
  430. ;;;                 A Table's Table-Member Method                     ;;;
  431. ;;;  ===========================================================================  ;;;
  432.   
  433. (DEFMETHOD table-member ((table table) row column)
  434.   ;;  Return NIL if there is no child at position row/column.
  435.   (DECLARE (VALUES (OR contact NULL)))
  436.   (LET ((wis (check-for-existing-wis table (contact-width table) (contact-height table)
  437.                      (contact-border-width table))))
  438.     (WHEN wis
  439.       (org-entry-kid (FIND-IF #'(lambda (x)
  440.                   (AND (= (org-entry-row x) row)
  441.                        (= (org-entry-column x) column)))
  442.                   (REST (what-if-organization wis)))))))
  443.   
  444. (DEFMETHOD (SETF table-member) (new-value (table table) row column)
  445.   ;;  What should we do with the child currently at position row/column?
  446.   ;;  Set its constraints to NIL?  Set just one of its constraints to NIL?
  447.   ;;  Error if there's one there?  I've chosen to blast its constraints.
  448.   (LET ((existing-child-at-that-position (table-member table row column)))
  449.     (WHEN existing-child-at-that-position
  450.       (SETF (table-row existing-child-at-that-position) nil
  451.         (table-column existing-child-at-that-position) nil))
  452.     (SETF (table-row new-value) row)
  453.     (SETF (table-column new-value) column)
  454.     (force-relayout table)
  455.     new-value))
  456.  
  457.  
  458.  
  459. ;;;  ===========================================================================  ;;; 
  460. ;;;                 A Table's Preferred-Size Method                          ;;;
  461. ;;;  ===========================================================================  ;;; 
  462.  
  463. (DEFMETHOD preferred-size ((table table) &key width height border-width)
  464.  
  465.   ;;
  466.   ;;  Handle the case where we have no children...
  467.   ;;
  468.   (with-slots (children) table
  469.     (UNLESS children
  470.       (RETURN-FROM preferred-size
  471.     (VALUES (+ (display-left-margin table) (display-right-margin table))
  472.         (+ (display-top-margin table) (display-bottom-margin table))
  473.         (contact-border-width table)))))
  474.     
  475.   
  476.   (with-slots ((old-width width) (old-height height) (old-border-width border-width)) table    
  477.  
  478.     ;;
  479.     ;;  When the caller specifies no what-if values and we have a good width & height, always
  480.     ;;  return our current values...
  481.     ;;
  482.     (WHEN (AND (NULL width) (NULL height) (/= 0 old-width) (/= 0 old-height))
  483.  
  484.       (RETURN-FROM preferred-size (VALUES old-width old-height old-border-width)))
  485.  
  486.     ;;
  487.     ;;  We need to what-if.  Figure out the width, height, and border-width to use...
  488.     ;;
  489.     (SETF width (OR width old-width)
  490.       height (OR height old-height)
  491.       border-width (OR border-width old-border-width))
  492.  
  493.     
  494.     (LET ((wis (check-for-existing-wis table width height border-width)))
  495.  
  496.       (UNLESS (AND (what-if-organization wis)
  497.            (= (what-if-preferred-width wis) width)
  498.            (= (what-if-preferred-height wis) height))
  499.     (place-children-physically table wis nil))
  500.  
  501.       (VALUES (what-if-preferred-width wis)
  502.           (what-if-preferred-height wis)
  503.           border-width))))
  504.  
  505.  
  506. ;;;  ===========================================================================  ;;; 
  507. ;;;                 A Table's Change-Layout Method                           ;;;
  508. ;;;  ===========================================================================  ;;; 
  509.  
  510. (DEFMETHOD change-layout ((table table) &optional newly-managed)
  511.   (declare (type (or null contact) newly-managed))
  512.   (DECLARE (SPECIAL *called-from-resize-method*))
  513.   
  514.   (with-slots (width height border-width) table
  515.     
  516.     ;;  Just update the current wis if a single child is being withdrawn...
  517.     (when (AND newly-managed (EQ (contact-state newly-managed) :withdrawn))
  518.       (LET ((wis (check-for-existing-wis table width height border-width)))
  519.     (WHEN wis
  520.       (SETF (REST (what-if-organization wis))
  521.         (DELETE newly-managed (REST (what-if-organization wis))
  522.             :key #'org-entry-kid)))))
  523.     
  524.     (LET (p-width p-height
  525.       (wis (check-for-existing-wis table width height border-width)))
  526.       ;;  With a change in layout we must really re-layout our children...
  527.       (unless (what-if-in-use wis)
  528.     (SETF (what-if-in-use wis) t)
  529.     (place-children-physically table wis t)
  530.     
  531.     ;;
  532.     ;;  Update the children's row/column constraints...
  533.     ;;
  534.     (DOLIST (o-e (REST (what-if-organization wis)))
  535.       (SETF (table-row (org-entry-kid o-e)) (org-entry-row o-e)
  536.         (table-column (org-entry-kid o-e)) (org-entry-column o-e)))
  537.     
  538.     (UNLESS (AND (BOUNDP '*called-from-resize-method*) *called-from-resize-method*)
  539.       (SETF p-width (what-if-preferred-width wis)
  540.         p-height (what-if-preferred-height wis))     
  541.       
  542.       (UNLESS (AND (= height p-height) (= width p-width))
  543.         (SETF (what-if-width wis) p-width
  544.           (what-if-height wis) p-height)          
  545.         (change-geometry table :width p-width :height p-height :accept-p t)))
  546.     (SETF (what-if-in-use wis) nil)))))
  547.  
  548.  
  549. ;;;  ===========================================================================  ;;; 
  550. ;;;                 A Table's Resize :after Method                           ;;;
  551. ;;;  ===========================================================================  ;;; 
  552.  
  553. (DEFMETHOD resize :after ((table table) width height b-width)
  554.   (DECLARE (IGNORE  width height b-width))
  555.   (LET ((*called-from-resize-method* t))
  556.     (DECLARE (SPECIAL *called-from-resize-method*))
  557.     (change-layout table)))
  558.  
  559.  
  560.                         
  561. ;;;  ===========================================================================  ;;; 
  562. ;;;                 A Table's Manage-Geometry Method                         ;;;
  563. ;;;  ===========================================================================  ;;; 
  564.  
  565. ;;;  This is not right yet.  It should run a what-if to get a Table size for the child's 
  566. ;;;  size change, but this is not possible yet -- the wis doesn't keep all children's
  567. ;;;  sizes.  Then it must call change-geometry to see if its parent will let it be that
  568. ;;;  size.  If so, it should return a thunk that invokes resize, not change-geometry.
  569.  
  570. (defmethod manage-geometry ((table table) child x y width height border-width &key)
  571.   (values
  572.       (if
  573.     (or (and x (/= x (contact-x child)))
  574.         (and y (/= y (contact-y child)))
  575.         (and width (/= width (contact-width child)))
  576.         (and height (/= height (contact-height child)))
  577.         (and border-width (/= border-width (contact-border-width child))))
  578.     #'(lambda (self)
  579.         (multiple-value-bind (p-w p-h p-b-w)
  580.         (preferred-size self)
  581.           (change-geometry self
  582.                    :width p-w
  583.                    :height p-h
  584.                    :border-width p-b-w
  585.                    :accept-p t)
  586.           (change-layout self)
  587.           (display-force-output (contact-display self))))
  588.     t)
  589.       (or x (contact-x child))
  590.       (or y (contact-y child))
  591.       (or width (contact-width child))
  592.       (or height (contact-height child))
  593.       (or border-width (contact-border-width child))))
  594.  
  595.  
  596.  
  597. ;;;
  598. ;;;   Internal routines that calculate the width/height of a table, given a What-if-Structure...
  599. ;;;        Calculate-Preferred-Width 
  600. ;;;        Calculate-Preferred-Height 
  601.  
  602. (DEFUN calculate-preferred-width (table wis)
  603.   (LET* ((ncolumns (what-if-ncolumns wis))
  604.      (column-widths (what-if-column-widths wis))
  605.      (table-width (+ (display-left-margin table)
  606.              (display-right-margin table)
  607.              (* (1- ncolumns) (display-horizontal-space table)))))
  608.     (DOTIMES (column ncolumns)
  609.       (INCF table-width (AREF column-widths column 0)))
  610.     table-width))
  611.  
  612.  
  613. (DEFUN calculate-preferred-height (table wis)
  614.   (with-slots (row-height separators) (THE table table)
  615.  
  616.     (LET* ((nrows (what-if-nrows wis))
  617.        (organization (what-if-organization wis))
  618.        (table-height (+ (display-top-margin table)
  619.                 (display-bottom-margin table)
  620.                 (* (1- nrows) (display-vertical-space table))))
  621.        (org-list (REST organization))
  622.        (fixed-row-heights row-height) height-for-this-row)
  623.  
  624.       (DO ((row 0 (1+ row)))
  625.       ((= row nrows))
  626.  
  627.     (MULTIPLE-VALUE-SETQ (height-for-this-row fixed-row-heights org-list)
  628.       (determine-a-rows-height row fixed-row-heights org-list))
  629.     
  630.     (INCF table-height height-for-this-row)
  631.  
  632.     ;;  Note:  The physical size of an OL UI separator (white-space) will be defined 
  633.     ;;       to be half the height of the row it follows.  A separator placed after
  634.     ;;       the last row will result in extra white-space at the bottom of the table.
  635.     (WHEN (MEMBER row separators)
  636.       (INCF table-height (FLOOR (+ height-for-this-row (display-vertical-space table)) 2))))
  637.       
  638.       table-height)))
  639.  
  640.  
  641. (DEFUN determine-a-rows-height (row fixed-row-heights org-list1)
  642.   (LET (fixed-height-for-this-row (height-for-this-row 0) found-a-kid-in-this-row-p)
  643.     
  644.     (TYPECASE fixed-row-heights
  645.       (integer
  646.        (SETF fixed-height-for-this-row fixed-row-heights))
  647.       (cons
  648.        (SETF fixed-height-for-this-row (FIRST fixed-row-heights))
  649.        (SETF fixed-row-heights (REST fixed-row-heights))))
  650.     
  651.     (IF fixed-height-for-this-row
  652.     (SETF height-for-this-row fixed-height-for-this-row)
  653.     
  654.     ;;else find the tallest element and the largest border width in this row...
  655.     (progn
  656.       (DO ((org-list1 org-list1 (REST org-list1))
  657.            kid1 org-entry1 (kid1s-row row))
  658.           ((OR (NULL org-list1) (AND found-a-kid-in-this-row-p (/= row kid1s-row))))
  659.         (SETF org-entry1 (FIRST org-list1))
  660.         (SETF kid1 (org-entry-kid org-entry1)
  661.           kid1s-row (org-entry-row org-entry1))
  662.         (WHEN (= row kid1s-row)
  663.           (SETF found-a-kid-in-this-row-p t)
  664.           (SETF height-for-this-row
  665.             (MAX height-for-this-row
  666.              (+ (org-entry-height org-entry1)
  667.                 (org-entry-border-width org-entry1)
  668.                 (org-entry-border-width org-entry1))))))))
  669.     ;;
  670.     ;;  Because all the members of a row may be withdrawn (and therefore not on the
  671.     ;;  what-if-organization list) it is quite possible to find no children in a row.  For now
  672.     ;;  such a row collapses to zero-height...
  673.     (VALUES height-for-this-row fixed-row-heights org-list1)))
  674.  
  675.  
  676.  
  677.  
  678.  
  679.  
  680. ;;;  ===========================================================================  ;;; 
  681. ;;;              The Guts of Table: Place-Children-Physically              ;;;
  682. ;;;  ===========================================================================  ;;; 
  683.  
  684. (DEFUN place-children-physically (table wis really-p)  
  685.   
  686.   (with-slots (children same-width-in-column same-height-in-row columns
  687.             column-alignment row-alignment
  688.             column-width row-height
  689.             separators) (THE table table)
  690.     
  691.     (LET (kid last-kid-processed height-for-this-row x1 y1
  692.       (fixed-row-heights (UNLESS (EQ row-height :maximum) row-height))
  693.       fixed-column-widths
  694.       width-for-this-column
  695.       childs-horizontal-size       ; Including border-widths.
  696.       childs-vertical-size           ; Including border-widths.
  697.       max-child-heights-by-row
  698.       max-child-widths-by-columns
  699.       org-entry kids-row kids-column
  700.       y)
  701.  
  702.       (UNLESS children
  703.     (RETURN-FROM place-children-physically))
  704.  
  705.       (CASE columns
  706.     (:none
  707.      (put-kids-into-maximum-unaligned-columns table wis really-p)
  708.      (RETURN-FROM place-children-physically))
  709.  
  710.     (:maximum
  711.      ;; XtNmaximumColumns.
  712.      ;; Must scan the kids to figure out what width each column should be.
  713.      (put-kids-into-maximum-aligned-columns table wis))
  714.     
  715.     (otherwise
  716.      (UNLESS (INTEGERP columns)
  717.        (ERROR "~s is not a legal value for :columns" columns))
  718.      ;; XtNrequestedColumns.
  719.      (put-kids-into-specified-number-of-columns table wis)))
  720.       
  721.       ;;
  722.       ;;  Position the children on the test sheet per the columnarization...
  723.       ;;
  724.       (WHEN really-p
  725.     (MULTIPLE-VALUE-SETQ (max-child-heights-by-row max-child-widths-by-columns)
  726.       (scan-for-largest-children wis))
  727.  
  728.     (LET ((org-list (REST (what-if-organization wis)))
  729.           (column-widths (what-if-column-widths wis)))
  730.       (SETF y (display-top-margin table))
  731.       (CATCH 'out-of-kids
  732.         (DOTIMES (row (what-if-nrows wis))
  733.           (SETF fixed-column-widths (UNLESS (EQ column-width :maximum) column-width))
  734.           
  735.           (MULTIPLE-VALUE-SETQ (height-for-this-row fixed-row-heights)
  736.         (determine-a-rows-height row fixed-row-heights org-list))
  737.           
  738.           (LET ((fixed-width-for-this-column
  739.               (AND (INTEGERP fixed-column-widths) fixed-column-widths))
  740.             (x (display-left-margin table)))
  741.         
  742.         ;;  Now set the row's elements' geometries...
  743.         (DOTIMES (column (what-if-ncolumns wis))
  744.           (WHEN (EQ kid last-kid-processed)
  745.             (SETF org-entry (FIRST org-list))
  746.             (WHEN (NULL org-entry)
  747.               (THROW 'out-of-kids t))
  748.             (SETF kid (org-entry-kid org-entry)
  749.               kids-row (org-entry-row org-entry)
  750.               kids-column (org-entry-column org-entry)))
  751.           
  752.           ;;  Figure out what width WE want this column to be...
  753.           (WHEN (CONSP fixed-column-widths)
  754.             (SETF fixed-width-for-this-column (FIRST fixed-column-widths)))
  755.           (SETF width-for-this-column
  756.             (OR fixed-width-for-this-column (AREF column-widths column 0)))
  757.           (WHEN (AND (= row kids-row) (= column kids-column))              
  758.             (SETF childs-horizontal-size (+ (org-entry-width org-entry)
  759.                             (org-entry-border-width org-entry)
  760.                             (org-entry-border-width org-entry))
  761.               childs-vertical-size (+ (org-entry-height org-entry)
  762.                           (org-entry-border-width org-entry)
  763.                           (org-entry-border-width org-entry)))
  764.             
  765.             (IF (EQ same-width-in-column :on)
  766.             (SETF childs-horizontal-size width-for-this-column
  767.                   x1 x)
  768.               ;; else...
  769.               (SETF childs-horizontal-size (MIN childs-horizontal-size
  770.                             width-for-this-column)
  771.                 x1 (CASE column-alignment
  772.                  (:left x)
  773.                  (:right (+ x (- width-for-this-column
  774.                          childs-horizontal-size)))
  775.                  (:center (+ x (FLOOR (- width-for-this-column
  776.                              childs-horizontal-size) 2))))))
  777.             
  778.             (IF (EQ same-height-in-row :on)
  779.             (SETF childs-vertical-size height-for-this-row
  780.                   y1 y)
  781.               ;; else...
  782.               (SETF childs-vertical-size (MIN childs-vertical-size
  783.                               height-for-this-row)
  784.                 y1 (CASE row-alignment
  785.                  (:top y)
  786.                  (:bottom (+ y (- height-for-this-row
  787.                           childs-vertical-size)))
  788.                  (:center (+ y (FLOOR (- height-for-this-row
  789.                              childs-vertical-size) 2))))))
  790.             
  791.             ;;
  792.             ;;   Reposition and/or resize the child iff needed...
  793.             ;;
  794.             (LET ((desired-width (- childs-horizontal-size
  795.                         (org-entry-border-width org-entry)
  796.                         (org-entry-border-width org-entry)))
  797.               (desired-height (- childs-vertical-size
  798.                          (org-entry-border-width org-entry)
  799.                          (org-entry-border-width org-entry))))
  800.               (with-state (kid)
  801.             (UNLESS (AND (= x1 (contact-x kid))
  802.                      (= y1 (contact-y kid)))
  803.               (move kid x1 y1))
  804.             (UNLESS (AND (= desired-width (contact-width kid))
  805.                      (= desired-height (contact-height kid))
  806.                      (= (org-entry-border-width org-entry)
  807.                      (contact-border-width kid)))
  808.               (resize kid desired-width desired-height
  809.                   (org-entry-border-width org-entry))))
  810.  
  811.               ;;
  812.               ;;   Done with this child, move on to the next...
  813.               ;;
  814.               (SETF org-list (REST org-list))
  815.               (SETF last-kid-processed kid)))      
  816.  
  817.             ;;
  818.             ;;   Whether or not a kid was placed at this row/column, move on to the
  819.             ;;   next column...
  820.             (INCF x (+ width-for-this-column
  821.                    (display-horizontal-space table)))
  822.             (WHEN (CONSP fixed-column-widths)
  823.               (SETF fixed-column-widths (REST fixed-column-widths))))
  824.             
  825.         ;;
  826.         ;;   Get vertical position of top of borders of next row's elements...
  827.         ;;
  828.         (INCF y (+ height-for-this-row
  829.                (display-vertical-space table)))
  830.         (WHEN (MEMBER row separators)
  831.           (INCF y (FLOOR (+ height-for-this-row
  832.                     (display-vertical-space table)) 2))))))
  833.       ))
  834.     
  835.     ;;
  836.     ;;   Having finished placing the kids we can put our preferred size into our wis...
  837.     ;;
  838.       (SETF (what-if-preferred-height wis) (calculate-preferred-height table wis)
  839.         (what-if-preferred-width wis) (calculate-preferred-width table wis))
  840.     )))
  841.  
  842.     
  843.   
  844. (DEFUN scan-for-largest-children (wis)
  845.   
  846.   (LET* ((max-child-heights-by-row (MAKE-ARRAY (what-if-nrows wis) :initial-element 0))
  847.      (max-child-widths-by-column (MAKE-ARRAY (what-if-ncolumns wis) :initial-element 0)))
  848.     
  849.     (DOLIST (org-entry (REST (what-if-organization wis)))
  850.       (LET ((row (org-entry-row org-entry))
  851.         (column (org-entry-column org-entry))
  852.         (total-child-width (+ (org-entry-width org-entry)
  853.                   (org-entry-border-width org-entry)
  854.                   (org-entry-border-width org-entry)))
  855.         (total-child-height (+ (org-entry-height org-entry)
  856.                    (org-entry-border-width org-entry)
  857.                    (org-entry-border-width org-entry))))
  858.     (SETF (SVREF max-child-heights-by-row row)
  859.           (MAX (SVREF max-child-heights-by-row row) total-child-height))
  860.     (SETF (SVREF max-child-widths-by-column column)
  861.           (MAX (SVREF max-child-widths-by-column column) total-child-width))))
  862.     
  863.     (VALUES max-child-heights-by-row max-child-widths-by-column)))
  864.  
  865.  
  866.  
  867. (DEFUN put-kids-into-specified-number-of-columns (table wis)
  868.  
  869.   (DECLARE (VALUES widths-for-columns))
  870.   
  871.   (with-slots (column-width columns children) (THE table table)
  872.     (LET* (fixed-width-for-this-column total-kid-width 
  873.        (fixed-widths-for-columns column-width))
  874.  
  875.       (SETF (what-if-ncolumns wis)      columns
  876.         (what-if-nrows wis)          (CEILING (LENGTH children) columns)
  877.         (what-if-column-widths wis) (MAKE-ARRAY `(,columns 2) :initial-element 0))
  878.  
  879.       ;;  Construct the organization list by assigning the children to specific row/column
  880.       ;;  positions in the Table...
  881.       (assign-kids-to-rows-and-columns table wis)
  882.  
  883.       ;;  Ncolumns was specified by the user.  Nrows was determined from this and by
  884.       ;;  assign-kids-to-rows-and-columns.  This routine scans the organization and builds the array
  885.       ;;  of (list column-width width-of-widest-entry-column) entries.  This array is left in the
  886.       ;;  column-widths slot.
  887.  
  888.       ;;
  889.       ;;  Find the widest child in each row, set the 2nd element of each width-of-columns
  890.       ;;  entry to the width of the widest child in that column...
  891.       ;;
  892.       (DO ((org-list1 (REST (what-if-organization wis)) (REST org-list1))
  893.        kid1 org-entry1 kid1s-column kid1s-row)
  894.       ((NULL org-list1))
  895.     (SETF org-entry1 (FIRST org-list1))
  896.     (SETF kid1 (org-entry-kid org-entry1)
  897.           kid1s-row (org-entry-row org-entry1)
  898.           kid1s-column (org-entry-column org-entry1))
  899.     (SETF total-kid-width (+ (org-entry-width org-entry1)
  900.                  (org-entry-border-width org-entry1)
  901.                  (org-entry-border-width org-entry1)))
  902.     (Setf (AREF (what-if-column-widths wis) kid1s-column 1)
  903.           (MAX (AREF (what-if-column-widths wis) kid1s-column 1) total-kid-width)))
  904.       
  905.  
  906.       ;;
  907.       ;;  Now go through the columns looking for those with pre-set widths.  Use any pre-set
  908.       ;;  width as the column's width, otherwise use the width of the column's widest child.
  909.       ;;
  910.       (SETF fixed-widths-for-columns column-width)
  911.       (DOTIMES (current-column (what-if-ncolumns wis))
  912.     ;;  Get current-column's fixed width, if any...
  913.     (SETF fixed-width-for-this-column 
  914.           (TYPECASE fixed-widths-for-columns
  915.         (integer fixed-widths-for-columns)
  916.         (CONS (PROG1 (FIRST fixed-widths-for-columns)
  917.                  (SETF fixed-widths-for-columns (REST fixed-widths-for-columns))))))
  918.     (SETF (AREF (what-if-column-widths wis) current-column 0)
  919.           (OR fixed-width-for-this-column (AREF (what-if-column-widths wis) current-column 1)))))))
  920.  
  921. (DEFUN find-first-parents-width (table)
  922.   (DO ((parent (contact-parent table) (contact-parent parent)))
  923.       ((NULL parent))
  924.     (UNLESS (ZEROP (contact-width parent))
  925.       (RETURN (contact-width parent)))))
  926.  
  927. (DEFUN put-kids-into-maximum-unaligned-columns (table wis really-p)
  928.  
  929.   (with-slots (children same-width-in-column) (THE table table)
  930.       
  931.     (LET* ((org-list (LIST nil))
  932.        (working-width (what-if-width wis))
  933.        (border-width (what-if-border-width wis)))
  934.       
  935.       (WHEN (ZEROP working-width)
  936.       (SETF working-width (- (find-first-parents-width table) border-width border-width)))
  937.       
  938.       ;;  Start by sorting the list of children by their row/column constraints.  Once this is
  939.       ;;  done we ignore the constraints from here on for :none layout policy...
  940.       (LET ((nkids (LENGTH children)))
  941.     (SETF (what-if-nrows wis) nkids
  942.           (what-if-ncolumns wis) nkids)
  943.     (assign-kids-to-rows-and-columns table wis))
  944.       
  945.       (LET ((next-x-pos (display-left-margin table))
  946.         (next-y-pos (display-top-margin table))
  947.         (largest-height-this-row 0)
  948.         (columns-this-row 0)
  949.         (ncolumns-in-table 0)
  950.         (nrows-in-table 0)
  951.         (preferred-width-of-table 0))
  952.     
  953.     (FLET
  954.       ((handle-the-end-of-a-row ()
  955.          (SETF ncolumns-in-table (MAX ncolumns-in-table columns-this-row))
  956.          (SETF preferred-width-of-table
  957.            (MAX preferred-width-of-table
  958.             (+ next-x-pos
  959.                (- (display-right-margin table)
  960.                   (display-horizontal-space table)))))
  961.          (SETF next-x-pos (display-left-margin table))
  962.          (INCF nrows-in-table)
  963.          (INCF next-y-pos (+ largest-height-this-row
  964.                  (display-vertical-space table)))
  965.          (SETF columns-this-row 0
  966.            largest-height-this-row 0))
  967.        )
  968.       
  969.       (DOLIST (child children)
  970.         (UNLESS (EQ (contact-state child) :withdrawn)
  971.           (MULTIPLE-VALUE-BIND (childs-p-width childs-p-height childs-p-border-width)
  972.           (preferred-size child)
  973.         (LET ((childs-total-width (+ childs-p-width (* 2  childs-p-border-width)))
  974.               (childs-total-height (+ childs-p-height (* 2  childs-p-border-width))))
  975.           
  976.           ;;
  977.           ;;  If cannot place this child at the end of this row, finish off this row and move
  978.           ;;  on to the next row...
  979.           ;;
  980.           (WHEN (< (- working-width next-x-pos (display-right-margin table))
  981.                childs-total-width)
  982.             (handle-the-end-of-a-row))
  983.           ;;
  984.           ;;  Position this child where we've decided it should go...
  985.           ;;
  986.           (WHEN really-p
  987.             (with-state (child)
  988.               (UNLESS (AND (= next-x-pos (contact-x child))
  989.                    (= next-y-pos (contact-y child)))
  990.             (move child next-x-pos next-y-pos))
  991.               (UNLESS (AND (= childs-p-width (contact-width child))
  992.                    (= childs-p-height (contact-height child))
  993.                    (= childs-p-border-width (contact-border-width child)))
  994.             (resize child childs-p-width childs-p-height childs-p-border-width))))
  995.           
  996.           ;;
  997.           ;;  Done with this child, move on to the next child and the next position in this
  998.           ;;  row...
  999.           ;;
  1000.           (PUSH (make-org-entry :kid child
  1001.                     :row  nrows-in-table
  1002.                     :column columns-this-row
  1003.                     :width childs-p-width
  1004.                     :height childs-p-height
  1005.                     :border-width childs-p-border-width) org-list)
  1006.           (INCF next-x-pos (+ childs-total-width
  1007.                       (display-horizontal-space table)))
  1008.           (SETF largest-height-this-row (MAX largest-height-this-row childs-total-height))
  1009.           (INCF columns-this-row)))))
  1010.  
  1011.       ;;
  1012.       ;;  Set into the what-if structure the height, width, and organization just calculated...
  1013.       ;;
  1014.       (handle-the-end-of-a-row)
  1015.       (SETF (what-if-nrows wis) nrows-in-table)
  1016.       (SETF (what-if-ncolumns wis) ncolumns-in-table)
  1017.       (SETF (what-if-preferred-height wis)
  1018.         (+ next-y-pos (- (display-vertical-space table))
  1019.            (display-bottom-margin table)))
  1020.       (SETF (what-if-preferred-width wis) preferred-width-of-table)
  1021.       (SETF (what-if-organization wis) (NREVERSE org-list))
  1022.       ;;
  1023.       ;;  Set up a fake column-widths array for others...
  1024.       ;;
  1025.       (SETF (what-if-column-widths wis)
  1026.         (MAKE-ARRAY `(,ncolumns-in-table 2) :initial-element 0))
  1027.       
  1028.       (SETF (AREF (what-if-column-widths wis) 0 0) (what-if-preferred-width wis)))))))
  1029.  
  1030.  
  1031. (DEFUN put-kids-into-maximum-aligned-columns (table wis)
  1032.   ;; This is a guessing procedure that implements the XtNmaximumColumns policy for row and column
  1033.   ;; layout.  Keep an array of items (column-width max-width-of-columns-items).  Create and
  1034.   ;; initialize it from the 1st child: identical column widths = 1st child's preferred width,
  1035.   ;; max-width-of-columns-items = 0.  Set NROWS to 0.  Then start trying to place the children
  1036.   ;; into these columns.  The 1st child will fit for sure, updating the 1st column's max-width.
  1037.   ;; The 2nd-Nth children may or may not fit.  If it does, update max-width.  If not, see if
  1038.   ;; other columns' can be made narrower to allow this column to be made wide enough for him to
  1039.   ;; fit.  If so, do it.  If not, we must reduce the number of columns by one, assigning them
  1040.   ;; equal widths, then start the layout process from the top.  Each time we try to place a child
  1041.   ;; in the first column, increment NROWS.
  1042.   
  1043.   ;; Note that while this routine tends to give about the same amount of space to each column,
  1044.   ;; the slack space for the columns may differ considerably.  After we find a child the cannot
  1045.   ;; fit in a column and reduce the number of columns to get more space, we give each column the
  1046.   ;; same, new, enlarged space.  If one column is actually fairly narrow and doesn't need more
  1047.   ;; space it'll end up with extra slack space around it.  A slack-space-smoothing routine should
  1048.   ;; be written to improve this.
  1049.   
  1050.   (DECLARE (VALUES nrows ncolumns column-widths))
  1051.   
  1052.   (with-slots (children column-width) (THE table table)
  1053.     
  1054.       (LET ((nkids (LENGTH children))
  1055.         (working-width (what-if-width wis))
  1056.         (working-border-width (what-if-border-width wis)))
  1057.     
  1058.     (WHEN (<= working-width 0)
  1059.       (SETF working-width (- (find-first-parents-width table)
  1060.                  working-border-width working-border-width)))
  1061.  
  1062.     ;;
  1063.     ;;  Start by sorting the list of children by their row/column constraints.  Once this is
  1064.     ;;  done we ignore the constraints from here on for :maximum layout policy...
  1065.     ;;
  1066.     (SETF (what-if-nrows wis) nkids
  1067.           (what-if-ncolumns wis) nkids)
  1068.     (assign-kids-to-rows-and-columns table wis)
  1069.     
  1070.     
  1071.     ;;  Start with an upper bound on the number of columns...
  1072.     (LET* ((ncolumns (MIN nkids (get-maximum-possible-ncolumns table working-width)))
  1073.            (column-widths (MAKE-ARRAY `(,ncolumns 2)))
  1074.            (column-widths-vector (MAKE-ARRAY (* 2 ncolumns) :displaced-to column-widths)))
  1075.                         
  1076.  
  1077.       ;;
  1078.       ;;  Each execution of this outer loop represents an attempt at fitting the children
  1079.       ;;  into a given number of columns.  The inner loop below does the actual laying out of
  1080.       ;;  the children; if it succeeds, it sets FINISHED to T as it exits.  If it fails, it
  1081.       ;;  decrements NCOLUMNS and leaves FINISHED NIL.
  1082.       ;;
  1083.       (DO* (finished
  1084.         (org-list (LIST nil))
  1085.         (org-tail org-list)
  1086.         next-row next-column)
  1087.            (finished
  1088.          ;;
  1089.          ;;  Make each column's real width equal to the widest child we've placed in it,
  1090.          ;;  adjust ncolumns by the number of unused columns...
  1091.          ;;
  1092.          (DOTIMES (column ncolumns)
  1093.            (IF (ZEROP (AREF column-widths column 1))
  1094.                (DECF ncolumns)
  1095.                (SETF (AREF column-widths column 0) (AREF column-widths column 1))))
  1096.          
  1097.          (SETF (what-if-column-widths wis) column-widths)
  1098.          (SETF (what-if-ncolumns wis) ncolumns)
  1099.          (SETF (what-if-organization wis) org-list)
  1100.          (SETF (what-if-nrows wis) (1+ next-row)))
  1101.            
  1102.         ;;  Initialize the first ncolumns elements of the column-widths array...
  1103.         ;;  Total horizontal space available for the columns:
  1104.         ;;      width - right-margin - left-margin - (n - 1)*horizontal-space.
  1105.         ;;  This total is divided into ncolumns equal chunks, with any extra white space
  1106.         ;;  being given a pixel at a time to the left-most columns.
  1107.         
  1108.         ;;  But not quite.  We need to handle fixed-width columns specially.  At this point
  1109.         ;;  we know how many columns we're (tentatively) giving the table, call it N.  We
  1110.         ;;  need to see how much of our space is occupied by fixed-width columns in the
  1111.         ;;  first N columns and how many there are, call it M.  The remaining N-M columns
  1112.         ;;  each gets 1/(N-M) of the remaining space.  Be careful abaout N=M!  And each
  1113.         ;;  fixed-width column gets *both* of its column-width entries initialized here to
  1114.         ;;  its fixed width so it'll look like there's no slack in that column (which there
  1115.         ;;  isn't).  Unlike a variable-width column, a fixed-width column never gets its
  1116.         ;;  2nd column-widths entry changed as we place kids in it.
  1117.  
  1118.         (LET ((total-fixed-width 0) (n-fixed-width-columns 0)
  1119.           (fixed-column-widths (UNLESS (EQ column-width :maximum) column-width)))
  1120.  
  1121.           ;;  Forget the column widths calculated last time through the loop...
  1122.           (FILL (THE vector column-widths-vector) nil)
  1123.           
  1124.           ;;  Calculate how much of the total table width is allocated to fixed-width
  1125.           ;;  columns...
  1126.           (COND
  1127.         ((NULL fixed-column-widths))
  1128.         ((INTEGERP fixed-column-widths)
  1129.          (SETF total-fixed-width (* ncolumns fixed-column-widths)
  1130.                n-fixed-width-columns ncolumns)
  1131.          (DOTIMES (column-number ncolumns)
  1132.            (SETF (AREF column-widths column-number 0)
  1133.              (SETF (AREF column-widths column-number 1) fixed-column-widths))))
  1134.         ((CONSP fixed-column-widths)
  1135.          (DO ((fixed-column-widths fixed-column-widths (REST fixed-column-widths))
  1136.               (column-number 0 (1+ column-number))
  1137.               fixed-width)
  1138.              ((OR (= column-number ncolumns)
  1139.               (ENDP fixed-column-widths)))
  1140.            (SETF fixed-width (FIRST fixed-column-widths))
  1141.            (WHEN fixed-width
  1142.              (INCF n-fixed-width-columns)
  1143.              (INCF total-fixed-width fixed-width)
  1144.              (SETF (AREF column-widths column-number 0)
  1145.                (SETF (AREF column-widths column-number 1) fixed-width)))))
  1146.         (t (ERROR "column-width is ~a." fixed-column-widths)))
  1147.           
  1148.           ;;  Now n-fixed-width-columns = # of fixed width columns in first ncolumns
  1149.           ;;      total-fixed-width     = # of pixels occupied by those columns
  1150.           ;;  and for each fixed-width column both column-widths entries = the fixed width.
  1151.  
  1152.           ;;  Take the remaining space and give it to the non-fixed-width columns...          
  1153.           (UNLESS  (ZEROP (- ncolumns n-fixed-width-columns))
  1154.         (MULTIPLE-VALUE-BIND (horizontal-space-for-each-var-column extra-white-space)
  1155.             (FLOOR (- working-width
  1156.                   (display-left-margin table)
  1157.                   (display-right-margin table)
  1158.                   (* (1- ncolumns) (display-horizontal-space table))
  1159.                   total-fixed-width)
  1160.                (- ncolumns n-fixed-width-columns))
  1161.           
  1162.           ;;  Assign the non-fixed-width space to the non-fixed-width columns.  Because
  1163.           ;;  we FILL column-widths with NIL each time through the main loop, only
  1164.           ;;  fixed-width columns will have none-NIL values in them.  Give the extra
  1165.           ;;  white-space to the left-most variable-width columns a pixel at a time.
  1166.           (DOTIMES (i ncolumns)
  1167.             (WHEN (NULL (AREF column-widths i 0))
  1168.               (SETF (AREF column-widths i 0)
  1169.                 (+ horizontal-space-for-each-var-column
  1170.                    (IF (ZEROP extra-white-space)
  1171.                    0
  1172.                    (PROGN (DECF extra-white-space) 1))))
  1173.               (SETF (AREF column-widths i 1) 0)))))
  1174.  
  1175.            
  1176.            (SETF org-list (LIST nil)
  1177.              org-tail org-list
  1178.              next-row -1
  1179.              next-column (1- ncolumns))
  1180.            
  1181.            ;;
  1182.            ;;  Try to lay the children into the columns sized as they are now...
  1183.            ;;
  1184.            (DOLIST (child children (SETF finished t))
  1185.          
  1186.          (UNLESS (EQ (contact-state child) :withdrawn)
  1187.            ;;
  1188.            ;;  If the column this child's to go in is beyond ncolumns, wrap to the first
  1189.            ;;  column of the next row...
  1190.            ;;
  1191.            (INCF next-column)
  1192.            (WHEN (= next-column ncolumns)
  1193.              (SETF next-column 0)
  1194.              (INCF next-row)
  1195.              (SETF fixed-column-widths (UNLESS (EQ column-width :maximum) column-width)))
  1196.            
  1197.            (LET* ((columns-width-right-now (AREF column-widths next-column 0))
  1198.               (fixed-width-for-this-column
  1199.                 (IF (LISTP fixed-column-widths)      ;; ERCM
  1200.                 (FIRST fixed-column-widths)
  1201.                 fixed-column-widths)))
  1202.  
  1203.              (UNLESS fixed-width-for-this-column            
  1204.             ;;  Find out what width the child thinks he should be...
  1205.             (MULTIPLE-VALUE-BIND (childs-width childs-height childs-border-width)
  1206.                 (preferred-size child :width columns-width-right-now)
  1207.               (DECLARE (IGNORE childs-height))
  1208.               
  1209.               ;;  Calculate how much horizontal space this child needs...
  1210.               (LET ((horizontal-space-for-this-child
  1211.                   (+ childs-width childs-border-width childs-border-width)))
  1212.                 
  1213.                 (COND
  1214.                   ((OR (<= horizontal-space-for-this-child columns-width-right-now)
  1215.                    (adjust-column-widths-so-child-fits
  1216.                      column-widths horizontal-space-for-this-child
  1217.                      next-column ncolumns))
  1218.                    (SETF (AREF column-widths next-column 1)
  1219.                      (MAX (AREF column-widths next-column 1)
  1220.                       horizontal-space-for-this-child)))
  1221.                   (t               
  1222.                    ;; else child can't fit in this column.  Reduce the number of
  1223.                    ;; columns and try again.
  1224.                    (DECF ncolumns)
  1225.                    (RETURN nil)))))))
  1226.  
  1227.            ;;  To get here we must have decided we can successfully place this kid at
  1228.            ;;  this position, so add an entry for it onto the org-list...
  1229.            (SETF (REST org-tail)
  1230.              (LIST (establish-org-entry child next-row next-column)))
  1231.            (SETF org-tail (REST org-tail))
  1232.            
  1233.            ;;  Advance to the next column's entry in the fixed-width list if there is
  1234.            ;;  one...
  1235.            (WHEN (CONSP fixed-column-widths)
  1236.              (SETF fixed-column-widths (REST fixed-column-widths)))))))))))
  1237.  
  1238.  
  1239. (DEFUN adjust-column-widths-so-child-fits (column-widths childs-width next-column ncolumns)
  1240.   
  1241.   (DO ((npixels-needed (- childs-width (AREF column-widths next-column 0))))
  1242.       ((ZEROP npixels-needed)
  1243.        (SETF (AREF column-widths next-column 0) childs-width)
  1244.        t)
  1245.     
  1246.     ;; Find column with greatest slack, if any...
  1247.     (LET ((max-slack 0) (max-slack-col nil))
  1248.       (DOTIMES (col ncolumns)
  1249.     (UNLESS (= next-column col)        ; Don't look at column child goes in
  1250.       (LET ((slack (- (AREF column-widths col 0) (AREF column-widths col 1))))
  1251.         (WHEN (> slack max-slack)
  1252.           (SETF max-slack slack
  1253.             max-slack-col col)))))
  1254.       
  1255.       ;;  If no column had any slack, return NIL...
  1256.       (UNLESS max-slack-col (RETURN nil))
  1257.  
  1258.       ;;  Otherwise take a pixel from the max-slack-col's width, reduce our goal by one, try
  1259.       ;;  again...
  1260.       (DECF (AREF column-widths max-slack-col 0))
  1261.       (DECF npixels-needed))))
  1262.  
  1263.  
  1264.  
  1265. (DEFUN get-maximum-possible-ncolumns (table width)
  1266.   "Returns the maximum number of columns possible given the specified constraints."
  1267.   (with-slots (children column-width) (THE table table)
  1268.     
  1269.     (LET* ((fixed-column-widths (UNLESS (EQ column-width :maximum) column-width))
  1270.        (minimum-column-width
  1271.          (- width (display-left-margin table) (display-right-margin table))))
  1272.  
  1273.       ;;
  1274.       ;;  If the caller specified a single fixed width for all columns, then that's it...
  1275.       ;;
  1276.       (IF (INTEGERP fixed-column-widths)
  1277.       (SETF minimum-column-width (MIN minimum-column-width fixed-column-widths))
  1278.  
  1279.     ;; else...
  1280.     (PROGN
  1281.       ;;
  1282.       ;;  If the caller specified a list of fixed widths (and nil's) for (some of) the
  1283.       ;;  columns, first find the minimum of these fixed column widths...
  1284.       ;;
  1285.       (WHEN (CONSP fixed-column-widths)
  1286.         (DOLIST (this-fixed-column-width fixed-column-widths)
  1287.           (WHEN this-fixed-column-width
  1288.         (SETF minimum-column-width
  1289.               (MIN minimum-column-width this-fixed-column-width)))))
  1290.       
  1291.       ;;
  1292.       ;;  Then as a crude approximation, find the narrowest child, not knowing what column
  1293.       ;;  the child will go in...
  1294.       ;;
  1295.       (DOLIST (kid children)
  1296.         (UNLESS (EQ (contact-state kid) :withdrawn)
  1297.           (MULTIPLE-VALUE-BIND (preferred-width preferred-height preferred-border-width)
  1298.           (preferred-size kid)
  1299.         (DECLARE (IGNORE preferred-height))
  1300.         (SETF minimum-column-width
  1301.               (MIN minimum-column-width
  1302.                (+ preferred-width preferred-border-width preferred-border-width))))))))
  1303.       
  1304.       ;;  Now that we have the smallest column width we could ever get, calculate and return the
  1305.       ;;  maximum number of columns we could ever have...
  1306.       (MIN (LENGTH children)
  1307.        (FLOOR (+ (- width
  1308.             (display-left-margin table)
  1309.             (display-right-margin table))
  1310.              (display-horizontal-space table))
  1311.           (+ minimum-column-width (display-horizontal-space table)))))))
  1312.  
  1313.  
  1314.  
  1315. ;;;
  1316. ;;;   These routines construct the ORGANIZATION list by placing each child at a specific
  1317. ;;;   row/column position
  1318. ;;;
  1319. ;;;.  Lexical variables:
  1320. ;;;    hole-pointer    where in the existing organization list to rplacd-in an entry for an
  1321. ;;;            unconstrained child -- the current "hole".  All entries in the
  1322. ;;;            organization list preceding this one are contiguous starting from row 0,
  1323. ;;;            column 0, so all attempts at child placement, regardless of the
  1324. ;;;            constraints, start from here.  Hole-row & hole-column are one row/col
  1325. ;;;            position beyond the row/col of (FIRST hole-pointer), unless (first
  1326. ;;;            hole-pointer) is NIL, in which case they are (0,0).
  1327. ;;;    hole-row    the row-number of the current hole.
  1328. ;;;    hole-column    the column-number of the current hole.
  1329. ;;;    ncolumns    the number of columns in the table.  Fixed.
  1330. ;;;    nrows        the number of rows in the table.  Can change if a child specifies a big
  1331. ;;;            row-constraint.
  1332. ;;;
  1333.  
  1334. (DEFUN assign-kids-to-rows-and-columns (table wis)
  1335.   (LET (hole-pointer hole-row hole-column ncolumns nrows)
  1336.     
  1337.     
  1338.     (DECLARE (inline insert-into-organization-list))
  1339.     (LABELS
  1340.       (
  1341.        ;;
  1342.        ;;   Makes sure the hole-pointer/row/column actually point at a hole.  If they currently
  1343.        ;;   point at an allocated table row/column, moves them over until they point at an
  1344.        ;;   unallocated one. 
  1345.        ;;
  1346.        (find-next-hole
  1347.      ()
  1348.      (DO* (org-entry org-row org-column
  1349.            (org-list hole-pointer))
  1350.           (nil)
  1351.        ;;
  1352.        ;;  Look at the next org-entry, the one just beyond the hole pointer.  The second -
  1353.        ;;  Nth times through the loop this also advances the hole-pointer...
  1354.        ;;
  1355.        (SETF hole-pointer org-list
  1356.          org-list (REST org-list))
  1357.        (WHEN org-list
  1358.          (SETF org-entry (FIRST org-list)
  1359.            org-row (org-entry-row org-entry)
  1360.            org-column (org-entry-column org-entry)))
  1361.        (WHEN (OR (NULL org-list)        ; Exhausted org-list.  Leave hole pointing at
  1362.                         ;    row/col one beyond the last org-entry.
  1363.              (/= org-row hole-row)    ; There's space between the previous org-entry
  1364.              (/= org-column hole-column))    ;    and this one.  Leave hole pointing
  1365.                         ;    at row/col one beyond the previous
  1366.                         ;    org-entry. 
  1367.          (RETURN))
  1368.        ;;
  1369.        ;;   The row/column position of the hole is occupied.  Move the row/column of the hole
  1370.        ;;   over one position, try again...
  1371.        ;;
  1372.        (WHEN (= (INCF hole-column) ncolumns)
  1373.          (INCF hole-row)
  1374.          (SETF hole-column 0))))
  1375.  
  1376.        ;;
  1377.        ;;   Insert KID into the organization list at INSERTION-POINT at ROW/COLUMN...
  1378.        ;;
  1379.        (insert-into-organization-list
  1380.      (kid insertion-point row column)
  1381.      (RPLACD insertion-point
  1382.          (CONS (establish-org-entry kid row column)
  1383.                (REST insertion-point)))
  1384.      (find-next-hole)     
  1385.      (WHEN (>= row nrows)            ; Update nrows if necessary.
  1386.        (SETF nrows (1+ row))))        ;   *
  1387.        
  1388.        ;;
  1389.        ;;   Inserts a kid with no constraints in the next hole, moves the hole pointers.  Always
  1390.        ;;   successful, so always returns T.
  1391.        ;;
  1392.        (place-a-kid-at-any-row-and-column
  1393.      (kid)
  1394.      (insert-into-organization-list kid hole-pointer hole-row hole-column)
  1395.      t)
  1396.        
  1397.        ;;
  1398.        ;;   Tries to insert a kid into a specific row/column, returning T if successful, NIL if
  1399.        ;;   not.  Fails if that row/column is already occupied or specified column is outside
  1400.        ;;   ncolumns.
  1401.        ;;
  1402.        (place-a-kid-at-a-specific-row-and-column
  1403.      (kid kid-row kid-column)
  1404.      
  1405.      (LET ((kid-position (+ (* ncolumns kid-row) kid-column))
  1406.            (last-occupied-position
  1407.          (IF (FIRST hole-pointer)
  1408.              (+ (* ncolumns (org-entry-row (FIRST hole-pointer)))
  1409.             (org-entry-column (FIRST hole-pointer)))
  1410.              -1)))
  1411.        (WHEN (OR (>= kid-column ncolumns)
  1412.              (>= last-occupied-position kid-position))
  1413.          (RETURN-FROM place-a-kid-at-a-specific-row-and-column nil))
  1414.        
  1415.        
  1416.        (DO ((org-list hole-pointer) insertion-point org-position)
  1417.            (nil)
  1418.          
  1419.          (SETF insertion-point org-list
  1420.            org-list (REST org-list))
  1421.          
  1422.          (SETF org-position
  1423.            (IF org-list
  1424.                (+ (* ncolumns (org-entry-row (FIRST org-list)))
  1425.               (org-entry-column (FIRST org-list)))
  1426.                (1+ kid-position)))
  1427.          
  1428.          (COND
  1429.            ((= org-position kid-position)    ; Kid's row/column occupied: failure.
  1430.         (RETURN-FROM place-a-kid-at-a-specific-row-and-column nil))
  1431.            ((> org-position kid-position)    ; Kid's row/column free: success.
  1432.         (insert-into-organization-list kid insertion-point kid-row kid-column)
  1433.         (RETURN-FROM place-a-kid-at-a-specific-row-and-column t))
  1434.            (t nil)))))
  1435.        
  1436.        ;;
  1437.        ;;   Tries to insert a kid into a specific row.
  1438.        ;;   Fails if row is full, returns NIL, otherwise is successful, returns T.
  1439.        ;;
  1440.        (place-a-kid-in-a-specific-row
  1441.      (kid kid-row)
  1442.  
  1443.      (WHEN (< kid-row hole-row)
  1444.        (RETURN-FROM place-a-kid-in-a-specific-row nil))
  1445.      
  1446.      (DO ((org-list hole-pointer) insertion-point
  1447.           (last-occupied-column
  1448.         (IF (FIRST hole-pointer) (org-entry-column (FIRST hole-pointer)) -1) org-column)
  1449.           org-entry (org-row kid-row) org-column)
  1450.          ((OR (NULL org-list)
  1451.           (> org-row kid-row))
  1452.           ;; Failure -- exit here iff couldn't insert child
  1453.           nil)
  1454.        (SETF insertion-point org-list
  1455.          org-list (REST org-list))
  1456.        (IF org-list
  1457.            (SETF org-entry (FIRST org-list)
  1458.              org-row (org-entry-row org-entry)
  1459.              org-column (org-entry-column org-entry))
  1460.          ;; else no more org-entries so fake one way out there...
  1461.          (SETF org-row (1+ kid-row)))
  1462.        
  1463.        (WHEN (OR (AND (= org-row kid-row)            ; In kid's row and there's a hole.
  1464.               (< (1+ last-occupied-column)    ;   *
  1465.                  org-column))        ;   *
  1466.              (AND (> org-row kid-row)        ; First org-entry beyond kid's row
  1467.               (< last-occupied-column    ;   and there's a hole at the end
  1468.                  (1- ncolumns))))        ;   of the kid's row.
  1469.          (insert-into-organization-list
  1470.            kid insertion-point kid-row (1+ last-occupied-column))
  1471.          (RETURN-FROM place-a-kid-in-a-specific-row t))))
  1472.        
  1473.        ;;
  1474.        ;;   Inserts a kid into a specific column.
  1475.        ;;   Fails if column is not within ncolumns, returns NIL, otherwise always successful,
  1476.        ;;   returns T.
  1477.        ;;
  1478.        (place-a-kid-in-a-specific-column
  1479.      (kid kids-column)
  1480.             
  1481.      (WHEN (>= kids-column ncolumns)
  1482.        (RETURN-FROM place-a-kid-in-a-specific-column nil))
  1483.      
  1484.      (DO* ((org-list hole-pointer) insertion-point
  1485.            (last-org-position -1 org-position) org-position
  1486.            (insertion-row (IF (< kids-column hole-column) (1+ hole-row) hole-row))
  1487.            (position-of-next-occurrence-of-kids-column
  1488.          (+ (* ncolumns insertion-row) kids-column)))
  1489.           (nil)
  1490.        
  1491.        (SETF insertion-point org-list
  1492.          org-list (REST org-list))
  1493.        
  1494.        (SETF org-position
  1495.          (IF org-list
  1496.              (+ (* ncolumns (org-entry-row (FIRST org-list)))
  1497.             (org-entry-column (FIRST org-list)))
  1498.              (1+ position-of-next-occurrence-of-kids-column)))
  1499.        
  1500.        (WHEN (< last-org-position
  1501.             position-of-next-occurrence-of-kids-column
  1502.             org-position)
  1503.          (insert-into-organization-list kid insertion-point insertion-row kids-column)
  1504.          (RETURN-FROM place-a-kid-in-a-specific-column t))
  1505.        ;; Calculate a new position-of-next-occurrence-of-kids-column if this org-entry is at
  1506.        ;; or beyond the current value...
  1507.        (WHEN (>= org-position position-of-next-occurrence-of-kids-column)
  1508.          (INCF position-of-next-occurrence-of-kids-column ncolumns)
  1509.          (INCF insertion-row))))
  1510.        
  1511.        ;;
  1512.        ;;  This is called by assign-kids-to-rows-and-columns when it realizes it is dealing with
  1513.        ;;  a :maximum or :none table.  The Table's children list is rebuilt to be
  1514.        ;;  the (already sorted) kids in the org-list followed by the kids in the free-list.
  1515.        ;;  Where unconstrained kids would normally be used to fill in holes in a
  1516.        ;;  fixed-number-of-columns table, there really are no holes for a :maximum or
  1517.        ;;  :none table so such children are just placed at the end of the Table's
  1518.        ;;  children list.
  1519.        ;;
  1520.        (build-sorted-list-of-children
  1521.      (table org-list free-list withdrawn-children)
  1522.      (with-slots (children) (THE table table)
  1523.        (LET* ((sorted-children-list (MAKE-LIST (LENGTH org-list)))    ; includes leading NIL.
  1524.           (next-sorted-children-list sorted-children-list)
  1525.           (last-sorted-children-list sorted-children-list))
  1526.          
  1527.          (DOLIST (org-entry (REST org-list))
  1528.            (SETF last-sorted-children-list next-sorted-children-list
  1529.              next-sorted-children-list (REST next-sorted-children-list))
  1530.            (RPLACA next-sorted-children-list (org-entry-kid org-entry)))
  1531.          
  1532.          (WHEN free-list
  1533.            (RPLACD last-sorted-children-list (NCONC free-list withdrawn-children)))
  1534.          (SETF children (REST sorted-children-list)))))
  1535.  
  1536.        )                    ; ...end of labels...
  1537.       
  1538.       ;; ====================================================================================
  1539.       ;;   The code for assign-kids-to-rows-and-columns (table wis):
  1540.       ;;   Constructs the what-if-organization list by assigning each kid to a specific
  1541.       ;;   row/column position in the table.
  1542.       ;;
  1543.       (with-slots (children) (THE table table)
  1544.     (LET (free-row free-col free (old-org-list (REST (what-if-organization wis)))
  1545.           withdrawn-children)
  1546.       (SETF (what-if-organization wis) (LIST nil)
  1547.         hole-pointer (what-if-organization wis)
  1548.         hole-row 0
  1549.         hole-column 0
  1550.         ncolumns (what-if-ncolumns wis)
  1551.         nrows (what-if-nrows wis))
  1552.       ;;  First try to place all the kids with definite row/column constraints.
  1553.       ;;  Any child specifying only a row goes on the free-col list.
  1554.       ;;  Any child specifying only a column goes on the free-row list.
  1555.       ;;  Any child specifying neither row nor column, or any child unable to be placed where
  1556.       ;;      its definite row/column constraints placed it, goes on the free list.
  1557.       (DOLIST (kid children)
  1558.         (COND
  1559.           ((NOT (EQ (contact-state kid) :withdrawn))
  1560.            (UNLESS (OR (NULL old-org-list)
  1561.                (EQ kid (org-entry-kid (FIRST old-org-list))))
  1562.          (CERROR "continue" "children and org-list don't match"))
  1563.            (LET ((row (OR (table-row kid)
  1564.                   (AND old-org-list (org-entry-row (FIRST old-org-list)))))
  1565.              (column (OR (table-column kid)
  1566.                  (AND old-org-list (org-entry-column (FIRST old-org-list))))))
  1567.          (SETF old-org-list (REST old-org-list))
  1568.          (COND
  1569.            ((AND row column)
  1570.             (UNLESS (place-a-kid-at-a-specific-row-and-column kid row column)
  1571.               (PUSH kid free)))
  1572.            (row
  1573.             (PUSH `(,kid ,row) free-col))
  1574.            (column
  1575.             (PUSH `(,kid ,column) free-row))
  1576.            (t
  1577.             (PUSH kid free)))))
  1578.           (t
  1579.            (PUSH kid withdrawn-children))))
  1580.       
  1581.       ;;  Now try to place all the kids specifying only a column.  Since it is always OK to
  1582.       ;;  create a new row, such kids can always be placed...
  1583.       (DOLIST (kid-and-column (NREVERSE free-row))
  1584.         (place-a-kid-in-a-specific-column (FIRST kid-and-column) (SECOND kid-and-column)))
  1585.       
  1586.       ;;  Now try to place all the kids specifying only a row.  If that row is full, place
  1587.       ;;  the child on the free list...
  1588.       (DOLIST (kid-and-row (NREVERSE free-col))
  1589.         (UNLESS (place-a-kid-in-a-specific-row (FIRST kid-and-row) (SECOND kid-and-row))
  1590.           (PUSH (FIRST kid-and-row) free)))
  1591.       
  1592.       ;;  Finally, place the kids that are on the free list.  These kids have no constraints,
  1593.       ;;  so they'll all be placed in holes scanning from top-left to bottom-right or new
  1594.       ;;  rows will be created to hold them...
  1595.       (IF (SYMBOLP (table-columns table))
  1596.           (build-sorted-list-of-children
  1597.         table (what-if-organization wis) (NREVERSE free) withdrawn-children)
  1598.           
  1599.           ;; else...
  1600.           (PROGN 
  1601.         (DOLIST (kid (NREVERSE free))
  1602.           (place-a-kid-at-any-row-and-column kid))
  1603.         ;;
  1604.         ;;  Rebuild the children list in the order of the what-if-organization
  1605.         ;;  followed by any :withdrawn children not on the what-if-organization list.
  1606.         ;;
  1607.         (DO ((children children (REST children))
  1608.              (organization (REST (what-if-organization wis)) (REST organization)))
  1609.             ((NULL organization)
  1610.              (DOLIST (withdrawn-child withdrawn-children)
  1611.                (RPLACA children withdrawn-child)
  1612.                (SETF children (REST children))))
  1613.           (RPLACA children (org-entry-kid (FIRST organization))))))
  1614.       
  1615.       (SETF (what-if-nrows wis) nrows))))))
  1616.  
  1617. ;;  This is called by assign-kids-to-rows-and-columns when it realizes it is dealing with a
  1618. ;;  :maximum or :none table.  The Table's children list is rebuilt to be the
  1619. ;;  (already sorted) kids in the org-list followed by the kids in the free-list.  Where
  1620. ;;  unconstrained kids would normally be used to fill in holes in a fixed-number-of-columns
  1621. ;;  table, there really are no holes for a :maximum or :none table so such children
  1622. ;;  are just placed at the end of the Table's children list.
  1623.  
  1624. (DEFUN build-sorted-list-of-children (table org-list free-list withdrawn-children)
  1625.   (with-slots (children) (THE table table)
  1626.     (LET* ((sorted-children-list (MAKE-LIST (LENGTH org-list)))    ; includes leading NIL.
  1627.        (next-sorted-children-list sorted-children-list)
  1628.        (last-sorted-children-list sorted-children-list))
  1629.       
  1630.       (DOLIST (org-entry (REST org-list))
  1631.     (SETF last-sorted-children-list next-sorted-children-list
  1632.           next-sorted-children-list (REST next-sorted-children-list))
  1633.     (RPLACA next-sorted-children-list (org-entry-kid org-entry)))
  1634.       
  1635.       (WHEN free-list
  1636.     (RPLACD last-sorted-children-list (NCONC free-list withdrawn-children)))
  1637.       (SETF children (REST sorted-children-list)))))
  1638.  
  1639.